home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / keyword.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-13  |  2.9 KB  |  115 lines
  1. /*
  2.  *
  3.  * k e y w o r d . c                -- Keywords management
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 19-Nov-1993 16:12
  22.  * Last file update: 13-May-1996 22:40
  23.  */
  24.  
  25. #include "stk.h"
  26.  
  27. static Tcl_HashTable k_table;
  28.  
  29. void STk_initialize_keyword_table(void)
  30. {
  31.   Tcl_InitHashTable(&k_table, TCL_STRING_KEYS);
  32. }
  33.  
  34. void STk_free_keyword(SCM keyword)
  35. {
  36.   Tcl_DeleteHashEntry(Tcl_FindHashEntry(&k_table, KEYVAL(keyword)));
  37. }
  38.  
  39. SCM STk_makekey(char *token)
  40. {
  41.   Tcl_HashEntry *p;
  42.  
  43.   *token = '-';  /* because keywords corresponds to Tk options */
  44.   if (p = Tcl_FindHashEntry(&k_table, token))
  45.     return (SCM) Tcl_GetHashValue(p);
  46.   else {
  47.     SCM keyword;
  48.     int absent;
  49.     
  50.    /* Be careful with GC: Create hash entry after the new cell to avoid 
  51.     * partially initialized table entry 
  52.     */
  53.     NEWCELL(keyword, tc_keyword);
  54.     p                 = Tcl_CreateHashEntry(&k_table, token, &absent);
  55.     KEYVAL(keyword) = Tcl_GetHashKey(&k_table, p);
  56.     Tcl_SetHashValue(p, (ClientData) keyword);
  57.     return keyword;
  58.   }
  59. }
  60.  
  61. PRIMITIVE STk_make_keyword(SCM str)
  62. {
  63.   SCM z;
  64.   char *s, *copy;
  65.  
  66.   switch (TYPE(str)) {
  67.     case tc_string: s = CHARS(str); break;
  68.     case tc_symbol: s = PNAME(str); break;
  69.     default:        Err("make-keyword: Bad parameter", str);
  70.   }
  71.  
  72.   copy = must_malloc(strlen(s)+2);
  73.   strcpy(copy+1, s); /* copy[0] will be set to '-' in STk_makekey */
  74.   z = STk_makekey(copy);
  75.   free(copy);
  76.  
  77.   return z;
  78. }
  79.  
  80. PRIMITIVE STk_keywordp(SCM obj)
  81. {
  82.   return KEYWORDP(obj)? Truth : Ntruth;
  83. }
  84.  
  85. PRIMITIVE STk_keyword2string(SCM obj)
  86. {
  87.   SCM res;
  88.  
  89.   if (NKEYWORDP(obj)) Err("keyword->string: bad keyword", obj);
  90.   res = STk_makestring(KEYVAL(obj));
  91.   CHARS(res)[0] = ':';
  92.   return res;
  93. }
  94.  
  95.  
  96. PRIMITIVE STk_get_keyword(SCM key, SCM l, SCM default_value)
  97. {
  98.   if (NKEYWORDP(key))   Err("get-keyword: bad keyword", key);
  99.   if (CONSP(l) || NULLP(l)) {
  100.     int i, len = STk_llength(l);
  101.  
  102.     if (len< 0 || len&1) goto Error;
  103.  
  104.     for (i = 0; i < len; i+=2) {
  105.       if (NKEYWORDP(CAR(l))) Err("get-keyword: bad keyword", CAR(l));
  106.       if (strcmp(KEYVAL(CAR(l)), KEYVAL(key)) == 0) return CAR(CDR(l));
  107.       l = CDR(CDR(l));
  108.     }
  109.     if (default_value == UNBOUND) Err("get-keyword: value not found for", key);
  110.     return default_value;
  111.   }
  112. Error:
  113.     Err("get-keyword: bad list", l);
  114. }
  115.